Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue32/sweetd/FILEDIRX.PAS

Pascal/Delphi Source File | 1997-12-07 | 7.9 KB | 256 lines

{*********************************************************}
{* FileDirX                                              *}
{* Copyright (c) Julian M Bucknall 1997                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Extended directory search routines                    *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit FileDirX;

interface

uses
  {$IFDEF Windows}
  WinTypes, WinProcs,
  {$ELSE}
  Windows,
  {$ENDIF}
  FileRegX,
  SysUtils;

type
  TdeType = (                  {types of entries in a directory}
             detFile,          {..file}
             detDirectory,     {..subdirectory}
             detVolumeID);     {..volume ID}
  TdeTypeSet = set of TdeType; {set of directory entries}

type
  TdeAttr = (                  {attributes for entries in a directory}
             deaNormal,        {..nothing special, normal}
             deaAltered,       {..it's been altered since last backup}
             deaReadOnly,      {..it's read only}
             deaHidden,        {..it's hidden}
             deaSystem);       {..it's a system entry}
  TdeAttrSet = set of TdeAttr; {set of direntry attributes}

const
  c_NormalEntries = [detFile, detDirectory];
    {-handy constant for the normal directory entries}
  c_AllAttrs = [deaNormal, deaAltered, deaReadOnly, deaHidden, deaSystem];
    {-handy constant for all attributes}

type
  TdeSearchRec = record
    srName   : string;            {name of directory entry}
    srType   : TdeType;           {type of directory entry}
    srAttrs  : TdeAttrSet;        {attribute set}
    srSize   : longint;           {size in bytes}
    srSizeHi : longint;           {size in bytes, high longint}
    srTime   : longint;           {timestamp MSDOS style}
    {---internal fields---}
    srFindTypes: TdeTypeSet;      {types to find}
    srFindAttrs: TdeAttrSet;      {attributes to match}
    srRegex    : PfrxBinPattern;  {compiled regex}
    {$IFDEF Windows}
    srSR       : TSearchRec;      {search rec}
    {$ENDIF}
    {$IFDEF Win32}
    srHandle   : THandle;         {find handle}
    srSR       : TWin32FindData;  {find data}
    {$ENDIF}
  end;

function FindFirstEx(const aPath        : string;
                     const aNamePattern : string;
                           aTypes       : TdeTypeSet;
                           aAttrs       : TdeAttrSet;
                       var aSearchRec   : TdeSearchRec) : integer;
function FindNextEx(var aSearchRec : TdeSearchRec) : integer;
procedure FindCloseEx(var aSearchRec : TdeSearchRec);

implementation

{===Helper routines==================================================}
function AddStarDotStar(const Path : string) : string;
begin
  if (Path[length(Path)] <> '\') then
    Result := Path + '\*.*'
  else
    Result := Path + '*.*';
end;
{--------}
function ConvertAttr(aOSAttr : integer) : TdeAttrSet;
begin
  Result := [];
  if ((faHidden and aOSAttr) <> 0) then
    Include(Result, deaHidden);
  if ((faSysFile and aOSAttr) <> 0) then
    Include(Result, deaSystem);
  if ((faReadOnly and aOSAttr) <> 0) then
    Include(Result, deaReadOnly);
  if ((faArchive and aOSAttr) <> 0) then
    Include(Result, deaAltered);
  if (Result = []) then
    Result := [deaNormal];
end;
{--------}
function ConvertType(aOSAttr : integer) : TdeType;
begin
  if ((faDirectory and aOSAttr) <> 0) then
    Result := detDirectory
  else if ((faVolumeID and aOSAttr) <> 0) then
    Result := detVolumeID
  else
    Result := detFile;
end;
{--------}
procedure CompleteSearchRec(var SR : TdeSearchRec);
{$IFDEF Windows}
begin
  with SR do begin
    srName := srSR.Name;
    srType := ConvertType(srSR.Attr);
    srAttrs := ConvertAttr(srSR.Attr);
    srSize := srSR.Size;
    srSizeHi := 0;
    srTime := srSR.Time;
  end;
end;
{$ELSE}
type
  LH = packed record L, H : word; end;
var
  LocalFileTime : TFileTime;
begin
  with SR do begin
    srName := srSR.cFileName;
    srType := ConvertType(srSR.dwFileAttributes);
    srAttrs := ConvertAttr(srSR.dwFileAttributes);
    srSize := srSR.nFileSizeLow;
    srSizeHi := srSR.nFileSizeHigh;
    FileTimeToLocalFileTime(srSR.ftLastWriteTime, LocalFileTime);
    FileTimeToDosDateTime(LocalFileTime, LH(srTime).H, LH(srTime).L);
  end;
end;
{$ENDIF}
{====================================================================}


{===Interfaced routines==============================================}
function FindFirstEx(const aPath        : string;
                     const aNamePattern : string;
                           aTypes       : TdeTypeSet;
                           aAttrs       : TdeAttrSet;
                       var aSearchRec   : TdeSearchRec) : integer;
var
  RegResult : TfrxCompileResult;
  FoundOne  : boolean;
begin
  FillChar(aSearchRec, sizeof(aSearchRec), 0);
  with aSearchRec do begin
    srFindTypes := aTypes;
    srFindAttrs := aAttrs;
    RegResult := FRXCompilePattern(aNamePattern, srRegex);
    if (RegResult <> frxcrSuccess) then begin
      Result := -ord(RegResult);
      Exit;
    end;
    {$IFDEF Windows}
    Result := SysUtils.FindFirst(AddStarDotStar(aPath), faAnyFile, srSR);
    if (Result <> 0) then begin
      FRXFreeBinPattern(srRegex);
    end
    {$ELSE}
    Result := 0;
    srHandle := Windows.FindFirstFile(PChar(AddStarDotStar(aPath)), srSR);
    if (srHandle = INVALID_HANDLE_VALUE) then begin
      FRXFreeBinPattern(srRegex);
      Result := GetLastError;
    end
    {$ENDIF}
    else begin
      FoundOne := false;
      while (Result = 0) and (not FoundOne) do begin
        CompleteSearchRec(aSearchRec);
        if (srType in srFindTypes) and
           ((srFindAttrs * srAttrs) = srAttrs) and
           FRXMatchesPattern(srRegex, srName) then begin
          FoundOne := true;
        end
        else begin
          {$IFDEF Windows}
          Result := SysUtils.FindNext(srSR);
          if (Result <> 0) then
            FRXFreeBinPattern(srRegex);
          {$ELSE}
          if not Windows.FindNextFile(srHandle, srSR) then begin
            CloseHandle(srHandle);
            FRXFreeBinPattern(srRegex);
            Result := GetLastError;
          end;
          {$ENDIF}
        end;
      end;
    end;
  end;
end;
{--------}
function FindNextEx(var aSearchRec : TdeSearchRec) : integer;
var
  FoundOne  : boolean;
begin
  with aSearchRec do begin
    {$IFDEF Windows}
    Result := SysUtils.FindNext(srSR);
    if (Result <> 0) then begin
      {do nothing};
    end
    {$ELSE}
    Result := 0;
    if not Windows.FindNextFile(srHandle, srSR) then begin
      Result := GetLastError;
    end
    {$ENDIF}
    else begin
      FoundOne := false;
      while (Result = 0) and (not FoundOne) do begin
        CompleteSearchRec(aSearchRec);
        if (srType in srFindTypes) and
           ((srFindAttrs * srAttrs) = srAttrs) and
           FRXMatchesPattern(srRegex, srName) then begin
          FoundOne := true;
        end
        else begin
          {$IFDEF Windows}
          Result := SysUtils.FindNext(srSR);
          {$ELSE}
          if not Windows.FindNextFile(srHandle, srSR) then begin
            Result := GetLastError;
          end;
          {$ENDIF}
        end;
      end;
    end;
  end;
end;
{--------}
procedure FindCloseEx(var aSearchRec : TdeSearchRec);
begin
  FRXFreeBinPattern(aSearchRec.srRegex);
  {$IFDEF Win32}
  if (aSearchRec.srHandle <> INVALID_HANDLE_VALUE) then begin
    CloseHandle(aSearchRec.srHandle);
    aSearchRec.srHandle := INVALID_HANDLE_VALUE;
  end;
  {$ENDIF}
end;
{====================================================================}

end.